home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGMISC
/
FPCDOCS.LZH
/
KERNEL1.SEQ
< prev
next >
Wrap
Text File
|
1988-09-29
|
31KB
|
974 lines
\ KERNEL1.SEQ Source code for KERNEL1.COM, modified by Tom Zimmer
ONLY FORTH META ALSO FORTH
TRUE CONSTANT INLINE_NEXT \ Enable Inline NEXT
DECIMAL
: ?.INLINE ( --- ) \ Print state of INLINE_NEXT
CR ." NEXT is currently " INLINE_NEXT >REV
IF [ASSEMBLER] INLINEON [FORTH]
." INLINE. "
ELSE [ASSEMBLER] INLINEOFF [FORTH]
." NOT " >NORM ." INLINE. "
THEN >NORM CR ;
?.INLINE
256 DP-T ! \ Set Dictionary pointer
0 DP-X ! \ Set LIST DP
HERE 9000 + ' TARGET-ORIGIN >BODY !
IN-META
: ]] ] ;
: [[ [COMPILE] [ ; FORTH IMMEDIATE META
FORWARD: DEFINITIONS
FORWARD: [
LABEL ORIGIN JMP HERE 8000 + \ jump to cold start: will be patched
JMP HERE 8000 + \ jump to warm start: will be patched
END-CODE
LABEL DPUSH PUSH DX END-CODE
LABEL APUSH PUSH AX END-CODE
LABEL >NEXT LODSW ES:
JMP AX END-CODE
\ Create the FORTH vocabulary as the first definition in dictionary.
HERE-T ,-Y \ valid "previous" CFA for "CREATE
HERE-Y HERE-T CNHASH !-Y \ first entry in >NAME hash table
HERE-T DUP 100 + CURRENT-T ! \ harmless
HERE-Y VOCABULARY FORTH FORTH DEFINITIONS
0 OVER 2+ !-Y ( link )
2+ SWAP >BODY-T
ASCII F 2* \ Hash in First char shifted left one
ASCII O + 2* \ Plus second char, sum shifted left one
5 + \ Plus length byte
#TTHREADS 1- AND 2* \ Determine which thread FORTH goes in.
+ !-T \ store it in the proper thread.
IN-META
VOCABULARY FILES
FILES DEFINITIONS
\ Create the linked list of files that have been loaded.
VARIABLE KERNEL1.SEQ
FORTH DEFINITIONS
VARIABLE XSEG
VARIABLE YSEG
LABEL ABNORM MOV AX, # $AD26 \ Value to restore in >NEXT
MOV >NEXT AX \ Restore it
MOV AX, # $E0FF \ Value to restore in >NEXT + 2
MOV >NEXT 2+ AX \ Restore it
XOR AX, AX
MOV DS, AX
MOV BX, # $471
MOV 0 [BX], AL
MOV AX, CS
MOV DS, AX
JMP ORIGIN 3 + END-CODE
LABEL BIOSBK PUSH AX
MOV AL, # $E9
MOV CS: >NEXT AL
MOV AX, # ABNORM >NEXT - 3 -
MOV CS: >NEXT 1+ AX
POP AX
IRET END-CODE
LABEL DOSBK PUSH AX
MOV AH, # 0 \ throw away BREAK KEY
INT $16
POP AX
CLC
RETF END-CODE
LABEL NEST \ JMP = 15 cycles
XCHG RP, SP \ 4 cycles
PUSH ES \ 10 sysles
PUSH IP \ 11 cycles
XCHG RP, SP \ 4 cycles
MOV DI, AX \ 2 cycles
MOV AX, 3 [DI] \ 18 cycles \ get relative segment
ADD AX, XSEG \ 15 cycles \ adjust by base of list space
MOV ES, AX \ 2 cycles \ move into ES
SUB IP, IP \ 3 cycles \ clear IP
NEXT
END-CODE
META
CODE EXIT ( -- )
XCHG RP, SP \ 4 cycles
POP IP \ 8 cycles
POP ES \ 8 cycles
XCHG RP, SP \ 4 cycles
NEXT
END-CODE
CODE UNNEST ( --- )
XCHG RP, SP \ 4 cycles
POP IP \ 8 cycles
POP ES \ 8 cycles
XCHG RP, SP \ 4 cycles
NEXT
END-CODE
CODE ?EXIT ( f1 -- ) \ exit from definition on boolean f1.
POP AX
OR AX, AX
0<> IF
JMP ' EXIT
THEN
NEXT
END-CODE
LABEL DODOES
XCHG RP, SP \ 4 cycles
PUSH ES \ 10 sysles
PUSH IP \ 11 cycles
XCHG RP, SP \ 4 cycles
POP DI
MOV AX, 0 [DI]
ADD AX, XSEG
MOV ES, AX
SUB IP, IP
NEXT END-CODE
VARIABLE UP
LABEL DOCONSTANT
POP BX PUSH 0 [BX]
NEXT END-CODE
LABEL DOVALUE \ Save as constant, but it is assumed
POP BX PUSH 0 [BX] \ the user may change it.
NEXT END-CODE
LABEL DOUSER-VARIABLE
POP BX
MOV AX, 0 [BX]
ADD AX, UP
1PUSH END-CODE
CODE (LIT) ( -- n )
LODSW ES: 1PUSH END-CODE
T: LITERAL ( n -- ) [TARGET] (LIT) ,-X T;
T: DLITERAL ( d -- ) [TARGET] (LIT) ,-X [TARGET] (LIT) ,-X T;
T: ASCII ( -- ) [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META] T;
T: ['] ( -- ) 'T >BODY @
[[ TRANSITION ]] LITERAL [META] T;
: CONSTANT ( n -- )
RECREATE 232 C,-T
[[ ASSEMBLER DOCONSTANT ]] LITERAL HERE 2+ - ,-T
DUP ,-T CONSTANT ;
: VALUE ( n -- )
RECREATE 232 C,-T
[[ ASSEMBLER DOVALUE ]] LITERAL HERE 2+ - ,-T
DUP ,-T VALUE ;
FORWARD: <(;CODE)>
T: DOES> ( -- )
[FORWARD] <(;CODE)> HERE-T ,-X
HERE-T ( DOES-OP ) 232 C,-T
[[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T
HERE-X PARAGRAPH-X + DUP DPSEG-X ! SEG-X @ - ,-T
DP-X OFF T;
: NUMERIC ( -- )
[FORTH] HERE [META] NUMBER DPL @ 1+
IF [[ TRANSITION ]] DLITERAL [META]
ELSE DROP [[ TRANSITION ]] LITERAL [META] THEN ;
: UNDEFINED ( -- )
HERE-X >XREL 0 ,-X
CR >IN @ BL WORD COUNT TYPE >IN !
15 #OUT @ - SPACES .SEQHANDLE
40 #OUT @ - SPACES ERRORLINE @ 4 .R
." Forward reference or unresolved."
IN-FORWARD [FORTH] CREATE [META] TRANSITION
[FORTH] , FALSE , [META]
DOES> FORWARD-CODE ;
[FORTH] VARIABLE T-IN META
: ] ( -- )
STATE-T ON IN-TRANSITION
BEGIN >IN @ T-IN !
BEGIN BL WORD DUP C@ 0= \ If nothing in line
?FILLBUFF \ Optionally refill buffer
INLENGTH 0> AND \ and input buf not empty
WHILE DROP 0 T-IN !
FILLTIB \ refill the buffer
REPEAT ?UPPERCASE FIND
IF EXECUTE
ELSE COUNT NUMERIC?
IF NUMERIC
ELSE T-IN @ >IN ! UNDEFINED
THEN
THEN STATE-T @ 0=
UNTIL ;
T: [ ( -- ) IN-META STATE-T OFF T;
T: ; ( -- ) [TARGET] UNNEST [[ TRANSITION ]] [ T;
: : ( -- ) TARGET-CREATE 233 C,-T \ a JUMP instruction
[[ ASSEMBLER NEST ]] LITERAL HERE 2+ - ,-T
HERE-X PARAGRAPH-X + DUP DPSEG-X !
SEG-X @ - ( DUP H. ) ,-T
DP-X OFF ] ; \ compile body addr
ASSEMBLER CLEAR_LABELS META
CODE DOBEGIN ( -- ) \ REALLY A NOOP
NEXT END-CODE
CODE DOTHEN ( -- ) \ REALLY A NOOP
NEXT END-CODE
CODE DOAGAIN ( -- )
MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE DOREPEAT ( -- )
LABEL DOREP1 MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE ?WHILE ( f -- )
POP AX OR AX, AX
JE DOREP1
ADD IP, # 2
NEXT END-CODE
CODE ?UNTIL ( f -- )
POP AX OR AX, AX
JE DOREP1
ADD IP, # 2
NEXT END-CODE
CODE BRANCH ( -- )
LABEL BRAN1 MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE ?BRANCH ( f -- )
POP AX OR AX, AX
JE BRAN1
ADD IP, # 2
NEXT END-CODE
T: BEGIN [TARGET] DOBEGIN X?<MARK T;
T: AGAIN [TARGET] DOAGAIN X?<RESOLVE T;
T: UNTIL [TARGET] ?UNTIL X?<RESOLVE T;
T: IF [TARGET] ?BRANCH X?>MARK T;
T: THEN [TARGET] DOTHEN X?>RESOLVE T;
T: ELSE [TARGET] BRANCH X?>MARK 2SWAP X?>RESOLVE T;
T: WHILE [TARGET] ?WHILE X?>MARK T;
T: REPEAT 2SWAP [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE T;
LABEL LOOPEXIT ( --- )
ADD RP, # 6 ADD IP, # 2
NEXT END-CODE
CODE UNDO ( --- )
ADD RP, # 6
NEXT END-CODE
CODE (LOOP) ( -- )
INC 0 [RP] WORD
JO LOOPEXIT
MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE (+LOOP) ( n -- )
AX POP ADD 0 [RP], AX
JO LOOPEXIT MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE (DO) ( l i -- )
POP DX POP BX
LABEL PDO1 XCHG RP, SP \ 4
LODSW ES: \ 12 + 2
PUSH AX \ 11
ADD BX, # $8000 \ 4
PUSH BX \ 11
SUB DX, BX \ 3
PUSH DX \ 11
XCHG RP, SP \ 4 = 62
NEXT END-CODE
CODE (?DO) ( l i -- )
POP DX POP BX
CMP BX, DX
JNE PDO1 MOV ES: IP, 0 [IP]
NEXT END-CODE
CODE (OF) ( n1 n2 -- n1 ) ( or ) ( n1 n1 -- )
POP AX POP BX
CMP AX, BX
0= IF
ADD IP, # 2 NEXT
ELSE
PUSH BX
MOV ES: IP, 0 [IP]
NEXT
THEN
END-CODE
CODE BOUNDS ( n1 n2 --- n3 n4 )
POP DX POP AX ADD DX, AX
2PUSH END-CODE
T: ?DO [TARGET] (?DO) X?>MARK T;
T: DO [TARGET] (DO) X?>MARK T;
T: LOOP [TARGET] (LOOP) 2DUP 2+ X?<RESOLVE X?>RESOLVE T;
T: +LOOP [TARGET] (+LOOP) 2DUP 2+ X?<RESOLVE X?>RESOLVE T;
ASSEMBLER >NEXT META CONSTANT >NEXT
ASSEMBLER NEST META CONSTANT >NEST
CODE EXECUTE ( cfa -- )
POP AX JMP AX END-CODE
CODE PERFORM ( addr-of-cfa -- )
LABEL DODEFER POP BX MOV AX, 0 [BX]
JMP AX END-CODE
CODE EXEC: ( N1 -- )
POP BX
SHL BX, # 1
ADD IP, BX
LODSW ES:
XCHG RP, SP \ 4
POP IP \ 8
POP ES \ 8
XCHG RP, SP \ 4 = 24
JMP AX END-CODE
LABEL DOUSER-DEFER
POP BX MOV BX, 0 [BX]
ADD BX, UP MOV AX, 0 [BX]
JMP AX END-CODE
CODE GO RET END-CODE ( ADDR --- )
CODE NOOP NEXT END-CODE
CODE PAUSE NOOP \ Gets patched
NOOP
NOOP
NEXT END-CODE
CODE I ( -- n ) MOV AX, 0 [RP] ADD AX, 2 [RP]
1PUSH END-CODE
CODE J ( -- n ) MOV AX, 6 [RP] ADD AX, 8 [RP]
1PUSH END-CODE
CODE K ( -- n ) MOV AX, 12 [RP] ADD AX, 14 [RP]
1PUSH END-CODE
CODE (LEAVE) ( -- )
LABEL PLEAVE ADD RP, # 4 MOV IP, 0 [RP]
ADD RP, # 2
NEXT END-CODE
CODE (?LEAVE) ( f -- )
POP AX OR AX, AX JNE PLEAVE
NEXT END-CODE
T: LEAVE [TARGET] (LEAVE) T;
T: ?LEAVE [TARGET] (?LEAVE) T;
CODE @ ( addr -- n )
POP BX PUSH 0 [BX]
NEXT END-CODE
CODE ! ( n addr -- )
POP BX POP 0 [BX]
NEXT END-CODE
CODE C@ ( addr -- char )
POP BX SUB AX, AX MOV AL, 0 [BX]
1PUSH END-CODE
CODE C! ( char addr -- )
POP BX POP AX MOV 0 [BX], AL
NEXT END-CODE
CODE CMOVE ( from to count -- )
CLD MOV BX, IP MOV AX, DS
POP CX POP DI POP IP
PUSH ES MOV ES, AX
REPNZ MOVSB
MOV IP, BX POP ES
NEXT END-CODE
CODE CMOVE> ( from to count -- )
STD MOV BX, IP MOV AX, DS
POP CX DEC CX
POP DI POP IP
ADD DI, CX ADD IP, CX INC CX
PUSH ES MOV ES, AX
REPNZ MOVSB
MOV IP, BX CLD POP ES
NEXT END-CODE
CODE PLACE ( from cnt to -- )
POP BX POP AX MOV 0 [BX], AL
INC BX PUSH BX PUSH AX
CLD MOV BX, IP MOV AX, DS
POP CX POP DI POP IP
PUSH ES MOV ES, AX
REPNZ MOVSB
MOV IP, BX POP ES
NEXT END-CODE
DECIMAL
CODE SP@ ( -- n )
MOV AX, SP 1PUSH END-CODE
\ Cant use the following because it doesn't work on an 8088.
\ PUSH SP NEXT END-CODE
CODE SP! ( n -- )
POP SP NEXT END-CODE
CODE RP@ ( -- addr )
PUSH RP NEXT END-CODE
CODE RP! ( n -- )
POP RP NEXT END-CODE
CODE DROP ( n1 -- )
ADD SP, # 2 NEXT END-CODE
CODE DUP ( n1 -- n1 n1 )
POP AX PUSH AX
1PUSH END-CODE
CODE SWAP ( n1 n2 -- n2 n1 )
POP DX POP AX
2PUSH END-CODE
CODE OVER ( n1 n2 -- n1 n2 n1 )
XCHG RP, SP
MOV AX, 2 [RP]
XCHG RP, SP
1PUSH END-CODE
CODE TUCK ( n1 n2 -- n2 n1 n2 )
POP AX POP DX
PUSH AX 2PUSH END-CODE
CODE NIP ( n1 n2 -- n2 )
POP AX ADD SP, # 2
1PUSH END-CODE
CODE ROT ( n1 n2 n3 --- n2 n3 n1 )
POP DX POP BX POP AX
PUSH BX 2PUSH END-CODE
CODE -ROT ( n1 n2 n3 --- n3 n1 n2 )
POP BX POP AX POP DX
PUSH BX 2PUSH END-CODE
CODE FLIP ( n1 -- n2 )
POP AX XCHG AL, AH
1PUSH END-CODE
CODE SPLIT ( n1 --- n2 n3 ) \ Splits n1 into two bytes, low, high
POP BX
SUB AX, AX
MOV AL, BL
PUSH AX
MOV AL, BH
1PUSH END-CODE
CODE ?DUP ( n1 -- [n1] n1 )
POP AX CMP AX, # 0
0<> IF
PUSH AX
THEN
1PUSH END-CODE
CODE R> ( -- n )
PUSH 0 [RP]
ADD RP, # 2
NEXT END-CODE
CODE R>DROP ( --- )
ADD RP, # 2
NEXT END-CODE
CODE DUP>R ( n1 --- n1 )
POP AX
PUSH AX
SUB RP, # 2
MOV 0 [RP], AX
NEXT END-CODE
CODE >R ( n -- )
SUB RP, # 2 \ 4
POP 0 [RP] \ 22 = 26 cycles
NEXT END-CODE
CODE 2R> ( -- n )
PUSH 2 [RP] \ 25
PUSH 0 [RP] \ 21
ADD RP, # 4 \ 4 = 50 cycles
NEXT END-CODE
CODE 2>R ( n -- )
SUB RP, # 4 \ 4
POP 0 [RP] \ 22
POP 2 [RP] \ 26 = 52 cycles
NEXT END-CODE
CODE R@ ( -- n )
PUSH 0 [RP]
NEXT END-CODE
CODE 2R@ ( -- n )
PUSH 2 [RP]
PUSH 0 [RP]
NEXT END-CODE
CODE PICK ( nm ... n2 n1 k -- nm ... n2 n1 nk )
POP BX SHL BX, # 1 ADD BX, SP
PUSH 0 [BX]
NEXT END-CODE
CODE AND ( n1 n2 -- n3 )
POP BX POP AX AND AX, BX
1PUSH END-CODE
CODE OR ( n1 n2 -- n3 )
POP BX POP AX OR AX, BX
1PUSH END-CODE
CODE XOR ( n1 n2 -- n3 )
POP BX POP AX XOR AX, BX
1PUSH END-CODE
CODE NOT ( n -- n' )
POP AX NOT AX
1PUSH END-CODE
-1 CONSTANT TRUE
0 CONSTANT FALSE
CODE CSET ( b addr -- )
POP BX POP AX OR 0 [BX], AL
NEXT END-CODE
CODE CRESET ( b addr -- )
POP BX POP AX
NOT AX AND 0 [BX], AL
NEXT END-CODE
CODE CTOGGLE ( b addr -- )
POP BX POP AX XOR 0 [BX], AL
NEXT END-CODE
CODE ON ( addr -- )
POP BX MOV 0 [BX], # TRUE WORD
NEXT END-CODE
CODE OFF ( addr -- )
POP BX MOV 0 [BX], # FALSE WORD
NEXT END-CODE
CODE -1! ( addr -- )
POP BX MOV 0 [BX], # TRUE WORD
NEXT END-CODE
CODE 0! ( addr -- )
POP BX MOV 0 [BX], # FALSE WORD
NEXT END-CODE
CODE INCR ( A1 --- )
POP BX INC 0 [BX] WORD
NEXT END-CODE
CODE DECR ( A1 --- )
POP BX DEC 0 [BX] WORD
NEXT END-CODE
CODE + ( n1 n2 -- sum )
POP BX POP AX ADD AX, BX
1PUSH END-CODE
CODE NEGATE ( n -- n' )
POP AX NEG AX
1PUSH END-CODE
CODE - ( n1 n2 -- n1-n2 )
POP BX POP AX SUB AX, BX
1PUSH END-CODE
CODE ABS ( n -- n )
POP AX
CWD
XOR AX, DX
SUB AX, DX
1PUSH
END-CODE
CODE 2+! ( d addr -- )
POP BX POP AX POP DX
ADD 2 [BX], DX ADC 0 [BX], AX
NEXT END-CODE
CODE +! ( n addr -- )
POP BX POP AX ADD 0 [BX], AX
NEXT END-CODE
CODE C+! ( n addr -- )
POP BX POP AX ADD 0 [BX], AL
NEXT END-CODE
\ Since the 8086 has a seperate IO path, we define a Forth
\ interface to it. Use P@ and P! to read or write directly to
\ the 8086 IO ports.
CODE PC@ ( port# -- n )
POP DX IN AL, DX SUB AH, AH
PUSH AX NEXT END-CODE
CODE P@ ( port# -- n )
POP DX IN AX, DX PUSH AX
NEXT END-CODE
CODE PC! ( n port# -- )
POP DX POP AX OUT DX, AL
NEXT END-CODE
CODE P! ( n port# -- )
POP DX POP AX OUT DX, AX
NEXT END-CODE
\ read drive path into addr, null terminated.
CODE PDOS ( addr drive --- f1 ) \ RETURN PATH OF DRIVE
pop dx pop ax
push si mov si, ax
mov ah, # $47 int $21
u< if
mov al, # 1
else
mov al, # 0
then
sub ah, ah pop si
1push end-code
#TTHREADS CONSTANT #THREADS
CODE 2* ( n -- 2*n )
POP AX SHL AX, # 1
1PUSH END-CODE
CODE 2/ ( n -- n/2 )
POP AX SAR AX, # 1
1PUSH END-CODE
CODE U2/ ( u -- u/2 )
POP AX SHR AX, # 1
1PUSH END-CODE
CODE U16/ ( u -- u/16 )
POP AX
SHR AX, # 1 SHR AX, # 1
SHR AX, # 1 SHR AX, # 1
1PUSH END-CODE
CODE 8* ( n -- 8*n )
POP AX SHL AX, # 1
SHL AX, # 1 SHL AX, # 1
1PUSH END-CODE
( n1 --- n2 )
CODE 1+ POP AX INC AX
1PUSH END-CODE
CODE 2+ POP AX ADD AX, # 2
1PUSH END-CODE
CODE 1- POP AX DEC AX
1PUSH END-CODE
CODE 2- POP AX SUB AX, # 2
1PUSH END-CODE
CODE UM* ( n1 n2 -- d )
POP AX POP BX MUL BX
XCHG DX, AX 2PUSH END-CODE
CODE * ( N1 N2 -- N3 )
POP AX POP BX MUL BX
1PUSH END-CODE
: U*D ( n1 n2 -- d ) UM* ;
CODE UM/MOD ( d1 n1 -- Remainder Quotient )
POP BX POP DX POP AX
CMP DX, BX
U>= ( divide by zero? )
IF
MOV AX, # -1 MOV DX, AX 2PUSH
THEN
DIV BX 2PUSH END-CODE
LABEL YES MOV AX, # TRUE 1PUSH END-CODE
CODE 0= ( n -- f )
POP AX OR AX, AX
JE YES
SUB AX, AX 1PUSH END-CODE
CODE 0< ( n -- f )
POP AX OR AX, AX
JS YES
SUB AX, AX 1PUSH END-CODE
CODE 0> ( n -- f )
POP AX OR AX, AX
JG YES
SUB AX, AX 1PUSH END-CODE
CODE 0<> ( n -- f )
POP AX OR AX, AX
JNE YES
SUB AX, AX 1PUSH END-CODE
CODE = ( n1 n2 -- f )
POP AX POP BX CMP BX, AX
JE YES
SUB AX, AX 1PUSH END-CODE
CODE <> ( n1 n2 -- f )
POP AX POP BX CMP BX, AX
JNE YES
SUB AX, AX 1PUSH END-CODE
\ : <> ( n1 n2 -- f ) = NOT ;
: ?NEGATE ( n1 n2 -- n3 ) 0< IF NEGATE THEN ;
CODE U< ( n1 n2 -- f )
POP AX POP BX CMP BX, AX
JB YES
SUB AX, AX 1PUSH END-CODE
CODE U> ( n1 n2 -- f )
POP AX POP BX CMP AX, BX
JB YES
SUB AX, AX 1PUSH END-CODE
LABEL YES1 MOV AX, # TRUE 1PUSH END-CODE
CODE < ( n1 n2 -- f )
POP AX POP BX CMP BX, AX
JL YES1
SUB AX, AX 1PUSH END-CODE
CODE > ( n1 n2 -- f )
POP AX POP BX CMP BX, AX
JG YES1
SUB AX, AX
LABEL PUSH1 1PUSH END-CODE
CODE MIN POP AX POP BX CMP BX, AX
JG PUSH1
LABEL MIN1 PUSH BX NEXT END-CODE
CODE MAX POP AX POP BX CMP BX, AX
JG MIN1
1PUSH END-CODE
: BETWEEN ( n1 min max -- f ) >R OVER > SWAP R> > OR NOT ;
: WITHIN ( n1 min max -- f ) 1- BETWEEN ;
CODE 2@ ( addr -- d )
POP BX
PUSH 2 [BX]
PUSH 0 [BX]
NEXT END-CODE
CODE 2! ( d addr -- )
POP BX POP 0 [BX] POP 2 [BX]
NEXT END-CODE
CODE 2DROP ( d -- )
ADD SP, # 4
NEXT END-CODE
CODE 3DROP ( n1 n2 n3 -- )
ADD SP, # 6
NEXT END-CODE
CODE 2DUP ( d -- d d )
POP AX POP DX
PUSH DX PUSH AX
2PUSH END-CODE
CODE 3DUP ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
POP AX POP DX POP BX
PUSH BX PUSH DX PUSH AX
PUSH BX
2PUSH END-CODE
CODE 2SWAP ( d1 d2 -- d2 d1 )
POP CX POP BX
POP AX POP DX
PUSH BX PUSH CX
2PUSH END-CODE
CODE 2OVER ( d2 d2 -- d1 d2 d1 )
XCHG RP, SP
MOV AX, 4 [RP]
MOV DX, 6 [RP]
XCHG RP, SP
2PUSH END-CODE
CODE D+ ( d1 d2 -- dsum )
POP AX POP DX
POP BX POP CX
ADD DX, CX ADC AX, BX
2PUSH END-CODE
CODE DNEGATE ( d# -- d#' )
POP AX
LABEL DNEG1 POP DX
NEG AX
NEG DX
SBB AX, # 0
2PUSH
END-CODE
CODE S>D ( n -- d )
POP AX CWD XCHG DX, AX
2PUSH END-CODE
CODE DABS ( d# -- d# )
POP AX
OR AX, AX
JS DNEG1
1PUSH END-CODE
CODE D2* ( d -- d*2 )
POP AX POP DX
SHL DX, # 1 RCL AX, # 1
2PUSH END-CODE
CODE D2/ ( d -- d/2 )
POP AX POP DX
SAR AX, # 1 RCR DX, # 1
2PUSH END-CODE
: D- ( d1 d2 -- d3 ) DNEGATE D+ ;
: ?DNEGATE ( d1 n -- d2 ) 0< IF DNEGATE THEN ;
: D0= ( d -- f ) OR 0= ;
: D= ( d1 d2 -- f ) D- D0= ;
: DU< ( ud1 ud2 -- f )
ROT SWAP 2DUP U<
IF 2DROP 2DROP TRUE
ELSE <> IF 2DROP FALSE ELSE U< THEN
THEN ;
: D< ( d1 d2 -- f )
2 PICK OVER =
IF DU<
ELSE NIP ROT DROP < THEN ;
: D> ( d1 d2 -- f ) 2SWAP D< ;
: 4DUP ( a b c d -- a b c d a b c d ) 2OVER 2OVER ;
: DMIN ( d1 d2 -- d3 ) 4DUP D> IF 2SWAP THEN 2DROP ;
: DMAX ( d1 d2 -- d3 ) 4DUP D< IF 2SWAP THEN 2DROP ;
: *D ( n1 n2 -- d# )
2DUP XOR >R ABS SWAP ABS UM* R> ?DNEGATE ;
: M/MOD ( d# n1 -- rem quot )
?DUP
IF dup>r 2DUP XOR >R >R DABS R@ ABS UM/MOD
SWAP R> ?NEGATE
SWAP R> 0<
IF NEGATE OVER
IF 1- R@ ROT - SWAP THEN
THEN r>drop
THEN ;
: MU/MOD ( d# n1 -- rem d#quot )
>R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
CODE / ( NUM DEN --- QUOT )
POP BX POP AX CWD
MOV CX, BX XOR CX, DX
0>= IF \ POSITIVE QUOTIENT CASE
IDIV BX 1PUSH
THEN
IDIV BX OR DX, DX
0<> IF
DEC AX
THEN
1PUSH END-CODE
CODE /MOD ( NUM DEN --- REM QUOT )
POP BX POP AX CWD
MOV CX, BX XOR CX, DX
0>= IF
IDIV BX 2PUSH
THEN
IDIV BX OR DX, DX
0<> IF
ADD DX, BX DEC AX
THEN
2PUSH END-CODE
: MOD ( n1 n2 -- rem ) /MOD DROP ;
CODE */MOD ( N1 N2 N3 --- REM QUOT )
POP BX POP AX POP CX
IMUL CX MOV CX, BX XOR CX, DX
0>= IF
IDIV BX 2PUSH
THEN
IDIV BX OR DX, DX
0<> IF
ADD DX, BX DEC AX
THEN
2PUSH END-CODE
: */ ( n1 n2 n3 -- n1*n2/n3 ) */MOD NIP ;
: ROLL ( n1 n2 .. nk n -- wierd )
>R R@ PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ;
: 2ROT ( a b c d e f - c d e f a b ) 5 ROLL 5 ROLL ;